perm filename UTIL4[ADM,DBL] blob
sn#171377 filedate 1975-08-06 generic text, type T, neo UTF8
(FILECREATED " 6-AUG-75 17:19:48" <LENAT>UTIL4.;19 15170
changes to: UTIL4COMS INIT-MAC CHANGE-B FIXCOMS FIXEDCONS
previous date: " 4-AUG-75 18:02:59" <LENAT>UTIL4.;16)
(LISPXPRINT (QUOTE UTIL4COMS)
T T)
[RPAQQ UTIL4COMS
((FNS ACCEPT-B AM-BT CHANGE-B CONDENSEB ED-1F ED-1P ED-1V ED-ALL ED-ALLF ED-ALLP ED-ALLV FORGOT-ANY GLOB
INIT-MAC INIT2 LISTF LISTFILES1 MAPB MAPP MCON MTOP NEW-VERSION NFACET NFUN RESET1 RESET2 RESTORE-EXPR
SAVE SHOWP TRANFUN UPCASE XEQ-CLEAN)
BB FIXCOMS FIXEDCONS GLOBALVARS REPR-FNS SAVECOMS STICKY-B STICKY-P SYS-FORGET-LIST UCASELST VERSION
(USERMACROS C COPY)
(P (INIT-MAC))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML MTOP MAPP MAPB]
(DEFINEQ
(ACCEPT-B
[LAMBDA (B SIM)
(CREATEB B)
(TERPRI)
[COND
((FMEMB SIM CONCEPTS))
((PRIN1 "NAME OF SIMILAR BEING... ")
(SETQ SIM (RATOM]
(TERPRI)
(SET B (COPY (GETTOPVAL SIM)))
(SETPROPLIST B (COPY (GETPROPLIST SIM)))
(ERRORSET (LIST (QUOTE EDITV)
B
(LIST (QUOTE RC)
SIM B)))
(ERRORSET (LIST (QUOTE EDITV)
B))
(ERRORSET (LIST (QUOTE EDITP)
B
(LIST (QUOTE RC)
SIM B)))
(ERRORSET (LIST (QUOTE EDITP)
B))
(DEFB B)
(PRIN1 "THE NUMBER OF CONCEPTS IS NOW ")
(PRINT (LENGTH CONCEPTS))
B])
(AM-BT
[LAMBDA (V1)
(MAPDL (FUNCTION (LAMBDA (DX)
(COND
((OR (FMEMB DX (CAR TOP4COMS))
(FMEMB DX (CAR UTIL4COMS))
(FMEMB DX CONCEPTS))
(PRIN1 DX)
(COND
((SETQ V1 (VARIABLES MAPDLPOS))
(TERPRI)
(PRIN1 " ")
(PRINT V1)
(PRIN1 " ")
(PRINT (STKARGS MAPDLPOS)))
((PRIN1 " ---NO ARGS")
(TERPRI])
(CHANGE-B
[LAMBDA (B P CP)
[COND
((OR (FMEMB B FACETS)
(FMEMB B AUX-FACETS))
(SETQ P B)
(PRINT (SETQ B STICKY-B)))
[(GETHASH B HCON)
(OR (FMEMB P FACETS)
(FMEMB P AUX-FACETS)
(PRINT (SETQ P STICKY-P]
(B (TERPRI)
(PRIN1 "***** CANT UNDERSTAND THIS *****")
(HELP))
(T (PRINT (SETQ B STICKY-B))
(PRINT (SETQ P STICKY-P]
(SETQ STICKY-B B)
(SETQ STICKY-P P)
(OR (GETB B P)
(INIT-PART B P))
(ERRORSET (LIST (QUOTE EDITP)
B
(QUOTE F)
P
(QUOTE P)
(QUOTE TTY:)))
(DEFB B)
(TERPRI)
(PRIN1 B)
(PRIN1 COMMA)
(PRINT P)
(SETQ FIXEDCONS (UNION B FIXEDCONS])
(CONDENSEB
[LAMBDA (CONFILE)
(SETQ DFNFLG NIL)
(MAPC NEW-PARTS (QUOTE RESTORE-EXPR))
(SETQ VERSION (ADD1 VERSION))
(SETQ CONFILE (PACK (LIST (QUOTE CON)
VERSION)))
(SET (PACK (LIST CONFILE (QUOTE COMS)))
(CONS (CONS (QUOTE FNS)
NEW-PARTS)
NEW-CONCEPTS))
(MAKEFILE CONFILE (QUOTE C))
(NCONC (DREMOVE (QUOTE DUMMY)
NEW-CONCEPTS)
CONCEPTS)
(SETQ NEW-CONCEPTS (LIST (QUOTE DUMMY)))
(SETQ NEW-PARTS NIL)
(SETQ NEW-C-PARTS NIL])
(ED-1F
[LAMBDA (F1)
(AND (ERRORSET (CONS (QUOTE EDITF)
(CONS F1 ECMS)))
(PRIN1 F1)
(PRIN1 " "])
(ED-1P
[LAMBDA (P1)
(AND (CDR P1)
(ERRORSET (CONS (QUOTE EDITP)
(CONS P1 ECMS)))
(PRIN1 P1)
(PRIN1 " "])
(ED-1V
[LAMBDA (V1)
(AND (LITATOM V1)
(OR (NEQ (QUOTE NOBIND)
(GETTOPVAL V1))
(CPRIN1 2 " WARNING: THE VARIABLE " V1 " IS UNBOUND. " CRLF))
(ERRORSET (CONS (QUOTE EDITV)
(CONS V1 ECMS)))
(PRIN1 V1)
(PRIN1 " "])
(ED-ALL
[LAMBDA (EECMS)
(SETQ ECMS EECMS)
(ED-ALLF)
(ED-ALLV)
(ED-ALLP])
(ED-ALLF
[LAMBDA NIL
(MAPC (CDAR TOP4COMS)
(QUOTE ED-1F))
(MAPC CONCEPTS (QUOTE ED-1F))
(MAPC FACETS (QUOTE ED-1F))
(MAPC (CDADR TOP4COMS)
(QUOTE ED-1F))
(MAPC (CDAR CON4COMS)
(QUOTE ED-1F))
(MAPC (CDAR UTIL4COMS)
(QUOTE ED-1F])
(ED-ALLP
[LAMBDA NIL
(MAPC CONCEPTS (QUOTE ED-1P])
(ED-ALLV
[LAMBDA NIL
(MAPC TOP4COMS (QUOTE ED-1V))
(MAPC CON4COMS (QUOTE ED-1V))
(MAPC UTIL4COMS (QUOTE ED-1V))
(MAPC CONCEPTS (QUOTE ED-1V))
(MAPC FACETS (QUOTE ED-1V])
(FORGOT-ANY
[LAMBDA (FF)
(TERPRI)
(PRIN1 "MAYBE YOU FORGOT SOME OF THESE: ")
[MAPATOMS (FUNCTION (LAMBDA (X)
(AND (EXPRP X)
(NOT (MEMB X (CAR TOP4COMS)))
(NOT (MEMB X (CADR TOP4COMS)))
(NOT (MEMB X (CAR UTIL4COMS)))
(NOT (MEMB X CONCEPTS))
(NOT (MEMB X SYS-FORGET-LIST))
(NOT (MEMB X FACETS))
[NOT (MATCH (UNPACK X) WITH (X1←--@[LAMBDA (Z)
(GETHASH Z HCON]
'- X2←--@(LAMBDA (Z)
(MEMB Z FACETS]
(NOT (MEMB X (CAR CON4COMS)))
(NOT (MATCH (UNPACK X) WITH (-- '- 'E '- --)))
(NOT (MATCH (UNPACK X) WITH (-- 'B &@NUMBERP &@NUMBERP &@NUMBERP &@NUMBERP)))
(PRIN1 X)
(PRIN1 (QUOTE % % ))
(SETQ FF T]
(COND
(FF (TERPRI)
(PRINT (QUOTE THINK!!!)))
(T (PRIN1 " NEVER MIND. ")))
(TERPRI])
(GLOB
[LAMBDA (GV)
[COND
((AND GV (NLISTP GV))
(SETQ GV (LIST GV]
(MERGE (SORT GV)
GLOBALVARS)
(SETQ GLOBALVARS (INTERSECTION GLOBALVARS GLOBALVARS))
(PRIN1 " THE NUMBER OF GLOBAL VARAIABLES IS NOW ")
(PRINT (LENGTH GLOBALVARS])
(INIT-MAC
[LAMBDA NIL
(DEFLIST [QUOTE ((FGETB ((B P)
(GETP B P)))
[GETB (X (COND
[(AND (LISTP (CADR X))
(EQ (CAADR X)
(QUOTE QUOTE)))
(COND
((GETP (CADADR X)
(QUOTE UNDO-INIT))
(LIST (GETP (CADADR X)
(QUOTE UNDO-INIT))
(CONS (QUOTE GETP)
X)))
(T (CONS (QUOTE GETP)
X]
(T (LIST (QUOTE APPLY*)
(LIST (QUOTE GETP)
(LIST (QUOTE SETQ)
(QUOTE PMAC)
(CADR X))
(LIST (QUOTE QUOTE)
(QUOTE UNDO-INIT)))
(LIST (QUOTE GETP)
(CAR X)
(QUOTE PMAC]
(ACCESS ((X)
X))
(GETBQ ((B P)
(GETB (QUOTE B)
P)))
(SETBQ ((B P Q)
(PUT (QUOTE B)
(QUOTE P)
Q)))
(UNDO-INIT ((P L)
(APPLY* (GETP P (QUOTE UNDO-INIT))
L)))
[APPLYB (X (COND
((AND (LISTP (CAR X))
(EQ (CAAR X)
(QUOTE QUOTE)))
(CONS (CADAR X)
(CDR X)))
(T (CONS (QUOTE APPLY*)
X]
(CSINT ((X)
(CAAR X)))
(CSOTHERS ((X)
(CDR X)))
(CSBEST ((X)
(CAR X)))
(CINT ((X)
(CAR X)))
(RPLACINT ((X Y)
(RPLACA X Y)))
(PINT ((X)
(CAR X)))
(P-OP ((X)
(CADR X)))
(P-B ((X)
(CADDR X)))
(P-P ((X)
(CADDDR X)))
(COP ((X)
(CADR X)))
(CB ((X)
(CADDR X)))
(CP ((X)
(CADDDR X)))
(CACT ((X)
(CDR X)))
[BPFS ((X)
(CDDR (CADDR (GETD X]
(IPRED ((X)
(CAR X)))
(IDEF ((X)
(CADR X)))
(IVAL ((X)
(CADDR X)))
(IFEATURES ((X)
(CDDR X)))
(IFEA ((X)
(CADR X)))
[TYPE (X (CAR (LAST X]
(ANY-OF (X (CONS (QUOTE OR)
X)))
(ANY1OF ((X)
(CAR X)))
[ANY1OF (X (PROGN (* RAND-MEMB X)
(CAR X]
(ALL-OF (X (CONS (QUOTE APPEND)
X)))
(Q ((X)
(QUOTE (QUOTE X]
(QUOTE MACRO])
(INIT2
[LAMBDA NIL
(SETQ DFNFLG T)
(SETQ LISPXHISTORY)
(SETQ EDITHISTORY])
(LISTF
[LAMBDA NIL
(TENEX "FTP
SAIL
LOG AM,DBL MER
SEND TOP4≠
TOP4
SEND CON4≠
CON4
SEND UTIL4≠
UTIL4
QUIT
"])
(LISTFILES1
[LAMBDA (X)
[COND
((NULL X)
(TERPRI)
(PRIN1 "NO MORE FILES TO LIST JUST NOW ")
(TERPRI))
((LISTP X)
(SETQ X (CAR X]
(TERPRI)
(SETQ X (UNPACK X))
[AND (EQ (CAR X)
(QUOTE <))
(SETQ X (CDR (FMEMB (QUOTE >)
X]
[SETQ X (PACK (LDIFF X (MEMB (QUOTE ;)
X]
(TERPRI)
(PRIN1 (CONCAT "SHOULD I FTP THE FILE " X " OVER TO SAIL? (Y,N)..."))
(COND
((EQ (RATOM)
(QUOTE Y))
(TENEX (CONCAT "FTP
SAIL
LOG AM,DBL MER
SEND " X "≠
" X "
QUIT
"])
(MAPB
[NLAMBDA (F)
(MAPC CONCEPTS (LIST (QUOTE LAMBDA)
(LIST (QUOTE B))
F])
(MAPP
[NLAMBDA (F)
(MAPC FACETS (LIST (QUOTE LAMBDA)
(LIST (QUOTE P))
F])
(MCON
[LAMBDA NIL
(SETQ CONCEPTS (SORT (COPY CONCEPTS)))
(FORGOT-ANY)
(MAKEFILE (QUOTE CON4)
(QUOTE RC])
(MTOP
[NLAMBDA (X)
[RPLACA TOP4COMS (CONS (QUOTE FNS)
(MERGE X (CDAR TOP4COMS]
(FORGOT-ANY)
(MAKEFILE (QUOTE TOP4)
(QUOTE RC])
(NEW-VERSION
[LAMBDA (NAME VNEW V OLD NEW)
[COND
(V)
((PROG1 (SETQ V VERSION)
(SETQ VERSION (ADD1 VERSION]
(SETQ OLD (PACK (LIST NAME V)))
[SETQ NEW (PACK (LIST NAME (OR VNEW (ADD1 V]
[NLSETQ (SET (PACK (LIST NEW (QUOTE COMS)))
(EVAL (PACK (LIST OLD (QUOTE COMS]
(PRIN1 (CONCAT "OLD: " OLD ", NEW: " NEW ", V:" V ", ECMS: " (QUOTE REPLACEMENT)))
(ED-ALL (LIST (QUOTE RC) OLD NEW])
(NFACET
[LAMBDA (F XEQ-FLAG SUF-FLAG)
[COND
((ATOM F)
(SETQ F (LIST F]
[MAPC F (FUNCTION (LAMBDA (F1)
(PUT F1 (QUOTE ARGS)
(LIST (QUOTE BA1)
(QUOTE BA2)
(QUOTE BA3)
(QUOTE BA4)))
(PUT F1 (QUOTE UNDO-INIT)
(QUOTE ACCESS))
(COND
(XEQ-FLAG (ATTACH F1 XEQ-PARTS)
(ATTACH F1 XS-PARTS)))
(COND
(SUF-FLAG (ATTACH F1 SUF-PARTS)))
(DEFP F1)
(SETQ GTEMP1 (GLUE (QUOTE ANYB)
F1))
(COND
((NOT (GETHASH GTEMP1 HCON))
(CREATEB GTEMP1)
(SET GTEMP1 NIL)
(PUTU GTEMP1 (QUOTE FROM-FILE)
(QUOTE CON4))
(SETB GTEMP1 (QUOTE GENL)
(LIST (QUOTE ANYB-ANYP]
(SETQ FACETS (SORT (UNION F FACETS)))
(PRIN1 " THE NUMBER OF FACETS IS NOW ")
(PRINT (LENGTH FACETS])
(NFUN
[LAMBDA (FUNC FIL)
[COND
((NULL FIL)
(SETQ FIL (QUOTE TOP4]
[SETQ FIL (PACK (LIST FIL (QUOTE COMS]
[RPLACA (EVAL FIL)
(CONS (QUOTE FNS)
(SORT (UNION FUNC (CDAR (EVAL FIL]
(PRIN1 " THERE ARE NOW ")
[PRIN1 (LENGTH (CAR (EVAL FIL]
(PRIN1 " FUNCTIONS ON ")
(PRINT FIL])
(RESET1
[LAMBDA NIL
[MAPB (OR (EQ B (QUOTE LIST-STRUC))
(PROGN (REMPROP B (QUOTE EXS))
(REMPROP B (QUOTE EXS-BDY]
(UNBREAK)
(BREAKDOWN)
(MAPC CONCEPTS (QUOTE BREAKDOWN))
(MAPC (CDAR TOP4COMS)
(QUOTE BREAKDOWN))
(CLOCK 2])
(RESET2
[LAMBDA NIL
(MAPB (OR (EQ B (QUOTE LIST-STRUC))
(PROGN (REMPROP B (QUOTE EXS))
(REMPROP B (QUOTE EXS-BDY])
(RESTORE-EXPR
[LAMBDA (BPNAME)
(UNSAVEDEF BPNAME (QUOTE EXPR])
(SAVE
[LAMBDA NIL
(MAKEFILE (QUOTE SAVE])
(SHOWP
[LAMBDA (P)
(SETQ GTEMP6 NIL)
(MAPB (AND (GETB B P)
(PRINT B)
(PRINT (GETB B P))
(SETQ GTEMP6 (NCONC1 GTEMP6 B))
(TERPRI)))
(PRIN1 " GTEMP6 = ")
GTEMP6])
(TRANFUN
[LAMBDA (F FIL1 FIL2 F1COMS F2COMS)
[COND
((ATOM F)
(SETQ F (LIST F]
[SETQ F1COMS (PACK (LIST FIL1 (QUOTE COMS]
[SETQ F2COMS (PACK (LIST FIL2 (QUOTE COMS]
[COND
((NLISTP (CAR F2COMS))
(PRIN1 " INITIALIZATION IS REQUIRED ")
(TERPRI)
(SET F2COMS (CONS (LIST (QUOTE FNS)
(QUOTE DUMMY))
(COPY (CDR (EVAL F1COMS]
(COND
((NLISTP (CAR F1COMS))
(HELP "FIRST FILE'S COMS IS NULL ")))
(SETQ F (SORT F))
(MERGE (COPY F)
(CDAR (EVAL F2COMS)))
(DREMOVE (QUOTE DUMMY)
(CAR (EVAL F2COMS)))
(MAPC F (FUNCTION (LAMBDA (F1)
(DREMOVE F1 (CAR (EVAL F1COMS])
(UPCASE
[LAMBDA NIL
(SETQ UCASELST (NCONC (SUBSET TOP4COMS (QUOTE ATOM))
(SUBSET CON4COMS (QUOTE ATOM])
(XEQ-CLEAN
[LAMBDA (B B1 B2 B3)
(MATCH (DREVERSE (UNPACK B)) WITH (B2←$
(QUOTE -)
B1←$))
(SETQ B1 (PACK (DREVERSE B1)))
(SETQ B2 (PACK (DREVERSE B2)))
(AND (FMEMB B2 FACETS)
(GETHASH B1 HCON)
NIL) (* NOTNEEDED APPARENTLY.
PERHAPS: in the function CREATEB)
])
)
(RPAQQ BB
(SET-STRUC-DELETE-E-INV STRUCTURE-MEMB STRUCTURE-INSERT RAND-MEMB SET-STRUC-DELETE OSET-STRUC INSTAN-PAT
INSTAN-REC INSTAN-BASE INSTAN-S INSTAN-D INSTAN-I INSTAN-1D INSTAN-1I INSTAN-1S
PICK-CAND XEQ-CAND UPDATE TLOOP GENL FILLIN PXEQ PGET APPLYB-P GETB-P-C RIPPLE-SIMULT
PSUF EXS RAND-THING))
[RPAQQ FIXCOMS ((FNS ANY1OFE ANY1OF-SATISFYING)
CONCEPTS FIXEDCONS TOP4COMS (COMS * (LIST (CONS (QUOTE IFPROP)
(CONS (QUOTE ALL)
FIXEDCONS]
(RPAQQ FIXEDCONS (ANYB-EXS))
(RPAQQ GLOBALVARS
(ALLOP ARGS AUX-FACETS B-DEF BAL1 BAL2 CAND CAND-TAIL CANDS CIRC COMMA CON4COMS CONCEPTS CONSTRUCTIVE-OPS CRLF
CS-ACT CS-B CS-INT CS-OP CS-P CVAL DO-THRESH ECMS EX-THRESH F-COUNTER FACETS FROB FROB1 GATH-PART
GEXISTING GLEN GPGM GPNAME GTEMP GTEMP1 GTEMP10 GTEMP11 GTEMP12 GTEMP13 GTEMP14 GTEMP16 GTEMP17 GTEMP18
GTEMP19 GTEMP2 GTEMP20 GTEMP22 GTEMP23 GTEMP24 GTEMP25 GTEMP26 GTEMP27 GTEMP28 GTEMP29 GTEMP3 GTEMP30
GTEMP4 GTEMP5 GTEMP6 GTEMP7 GTEMP8 GTEMP9 GXTR-PART HCON ILEV INIT-CANDS INIT-DOTHRESH INIT-EXTHRESH
INIT-INT-THRESH INIT-INTHRESH INIT-ONCE-LIST INIT-PAST INT-THRESH INTHRESH JTRASH NEW-C-PARTS NEW-CANDS
NEW-CONCEPTS NEW-ILEV NEW-PARTS NEWB NOSWAP-CONCEPTS OBJX ONCE-LIST OR-PARTS PAST PHIST PKNT PMAC PREC
RANC RANDSTATE RANF RANU RB1 RTEM2 STICKY-B STICKY-P STRAT STRATEGY-PARTS SUF-PARTS SUF1 SUF2 SWSUF
SYS-FORGET-LIST TMP1 TMP2 TMP3 TMP4 TMP5 TMP6 TMP7 TMP8 TMP9 TOP-ACTS TOP4COMS TRIV-B TRIVB USERNAMES
UTIL4COMS VERBOSITY VERSION XEQ-PARTS XS-PARTS))
(RPAQQ REPR-FNS
(ACCEPT-B APPLYB BPFS CHANGE-B CREATEB DECRB DEFB DEFP DWIMUSERFN GCB GETB GETBQ GETU GLUE GLUEE INCRB
INIT-PART PGET PSUF PUTB PUTU PXEQ SETB SETBQ SWAPB SWGETB SWSETB))
(RPAQQ SAVECOMS (PAST CANDS DO-THRESH INTHRESH EXTHRESH RANDSTATE ILEV PHIST ONCE-LIST PKNT RANU RANC OBJX))
(RPAQQ STICKY-B COMPOSE-FINAL&STRUCTURE-DIFF)
(RPAQQ STICKY-P WORTH)
(RPAQQ SYS-FORGET-LIST (DISPLAYTERMP PRETTYCOMPRINT PACK-IN-COMPBLOCK MAKESYS OBIN FGETP OSIN SYSOUT OSFBSZ PUTDQ
/SETPROPLIST SETTOPVAL /SETTOPVAL SETPROPLIST SETFILEPTR))
(RPAQQ UCASELST
(CAND-TAIL COMMA CONSTRUCTIVE-OPS CRLF DO-THRESH DWIMUSERFN EX-THRESH F-COUNTER INIT-CANDS INIT-ONCE-LIST
INIT-PAST INIT-DOTHRESH INIT-EXTHRESH INIT-INTHRESH INTHRESH JTRASH RANDSTATE TOP-ACTS TRIVB
USERNAMES VERBOSITY CONCEPTS FACETS AUX-FACETS SUF-PARTS XEQ-PARTS XS-PARTS))
(RPAQQ VERSION 4)
(ADDTOVAR USERMACROS (COPY (N)
(INSERT (## N)
AFTER N))
(C NIL (MBD * *)))
(ADDTOVAR EDITCOMSA C)
(ADDTOVAR EDITCOMSL COPY)
(INIT-MAC)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA)
(ADDTOVAR NLAML MTOP MAPP MAPB)
]
(DECLARE: DONTCOPY
(FILEMAP (NIL (791 12379 (ACCEPT-B 803 . 1421) (AM-BT 1425 . 1845) (CHANGE-B 1849 . 2546) (CONDENSEB 2550 . 3067)
(ED-1F 3071 . 3186) (ED-1P 3190 . 3317) (ED-1V 3321 . 3569) (ED-ALL 3573 . 3668) (ED-ALLF 3672 . 3949) (ED-ALLP 3953
. 4011) (ED-ALLV 4015 . 4212) (FORGOT-ANY 4216 . 5113) (GLOB 5117 . 5387) (INIT-MAC 5391 . 7581) (INIT2 7585 . 7677)
(LISTF 7681 . 7808) (LISTFILES1 7812 . 8357) (MAPB 8361 . 8454) (MAPP 8458 . 8559) (MCON 8563 . 8693) (MTOP 8697 .
8856) (NEW-VERSION 8860 . 9299) (NFACET 9303 . 10107) (NFUN 10111 . 10440) (RESET1 10444 . 10718) (RESET2 10722 .
10860) (RESTORE-EXPR 10864 . 10934) (SAVE 10938 . 10987) (SHOWP 10991 . 11210) (TRANFUN 11214 . 11870) (UPCASE 11874
. 11991) (XEQ-CLEAN 11995 . 12376)))))
STOP